Personal Computer World 2006 May/PCWMAY06.iso/Software/Trial/ConceptDraw NetDiagrammer/data1.cab/Samples__Basic/Solutions/OrgChart/loadXMLFunctions.cdb

Text File | 2006-02-08 | 17KB | 380 lines

'Функция BuildOrgTreeFromXML зачитывает данные о структуре организации из XML-файла
'и заполняет массивы, в которых хранятся данные о сотруднике и его положении в структуре.
Function BuildOrgTreeFromXML(ByRef strXMLFileName As String) As Boolean
On Error GoTo ErrHandle
Dim intFileNumber As Integer        'Идентификатор обрабатываемого XML-файла
Dim intRetTagValue As Integer        'Последнее значение, которое возвращает функция, извлекающая следующий тэга. Содержит информацию об успешности получения данных.
Dim intRetValValue As Integer        'Последнее значение, которое возвращает функция, извлекающая содержимое тэга. Содержит информацию об успешности получения данных.
Dim strTag As String            'Полная строка тэга, заключенная между скобками "<" и ">"
Dim strTagName As String        'Имя тэга, получающееся из строки strTag после отбрасывания аттрибутов тэга
Dim strTagValue As String        'Значение тэга.

Dim iDepthLevel As Integer        'Уровень вложенности данных сотрудника в XML-файле. Определяется количеством начальства у сотрудника.
Dim iIDCounter As Integer        'Индекс данного сотрудника.
Dim iChiefIndex As Integer        'Индекс непосредственного начальника данного сотрудника.
Dim aiChiefStack() As Integer        'Стэк, в который заносятся индексы всех руководителей текущего сотрудника в соответствии со вложенностью данных в XML-файле.
Dim iChiefStackUBound  As Integer    'Верхняя граница массива iChiefStackUBound

Dim i As Integer
Dim j As Integer

strOrgName = ""
ReDim aiChiefStack(0) As Integer
aiChiefStack(0) = 0
iChiefStackUBound = 0
iUBound = 0
iUBound2= 0
RedimArrays(0, 0)

'Открытие XML-файла для чтения данных
intFileNumber = FreeFile()
Open strXMLFileName For Input As #intFileNumber

intRetTagValue = 1
intRetValValue = 1
iDepthLevel = 1
iIDCounter = 0
'Получение и обработка данных файла до тех пор, пока не будет достигнут конец файла или
'не возникнет ошибка.
Do While 1 = intRetTagValue And 1 = intRetValValue
    'Загрузить в строковую переменную strTag следующий тэг.
    intRetTagValue = GetXMLTag(strTag, intFileNumber)
    'Если тэг зачитан...
    If intRetTagValue = 1 Then
        '...то отсекаются лишние пробелы...
        strTag = Trim$(strTag)
        '...и заменяются символы возврата каретки и перевода строки.
        ReplaceChr10And13(strTag)
        'Получить имя тэга.
        If InStr(strTag, " ") Then
            strTagName = Left(strTag, InStr(strTag, " "))
        Else
            strTagName = strTag
        End If
        Select Case strTagName
        'Открывающий тэг, описывающий данные следующего сотрудника
        Case constrPersonTag
            'Инкрементируем счетчик индексов сотрудников.
            iIDCounter = iIDCounter + 1
            'Определяем индекс руководителя сотрудника
            If iDepthLevel = 1 Then
                iChiefIndex = 0
            Else
                iChiefIndex = aiChiefStack(iDepthLevel - 1)
            End If
            'У начальника данного сотрудника добавляем ссылку на нового подчиненного.
                  asSubordinates(iChiefIndex, asSubordCount(iChiefIndex)) = iIDCounter
                  asSubordCount(iChiefIndex)=asSubordCount(iChiefIndex) + 1
            'Увеличиваем размерности массивов для помещения в них данных нового сотрудника
            If iUBound2<asSubordCount(iChiefIndex) Then
                 RedimArrays(iUBound + 1, iUBound2 + 1)
            Else
                 RedimArrays(iUBound + 1, iUBound2)
            End If
            asID(iIDCounter) = CStr(iIDCounter)
            If iDepthLevel = 1 Then
                asChiefID(iIDCounter) = ""
            Else
                asChiefID(iIDCounter) = CStr(iChiefIndex)
            End If
        'Открывающий тэг списка подчиненных сотрудника.
        Case constrSubordinatesTag
            'При необходимости увеличиваем размер стэка руководителей сотрудников
            If iChiefStackUBound < iDepthLevel Then
                iChiefStackUBound = iDepthLevel
                ReDim Preserve aiChiefStack(iChiefStackUBound) As Integer
            End If
            'Помещаем в стэк индекс текущего сотрудника и увеличиваем счетчик уровней вложенности
            aiChiefStack(iDepthLevel) = iIDCounter
            iDepthLevel = iDepthLevel + 1
        'Закрывающий тэг списка подчиненных сотрудника.
        Case "/" & constrSubordinatesTag
            iDepthLevel = iDepthLevel - 1
        'Открывающий тэг имени сотрудника.
        Case constrNameTag
            'Зачитать значение имени сотрудника
            intRetValValue = GetXMLTextValue(strTagValue, intFileNumber)
            'Если тэг зачитан без ошибок, поместить данные в массив.
            If intRetValValue = 1 Then
                asName(iUBound) = strTagValue
            End If
        'Открывающий тэг должности сотрудника.
        Case constrPostTag
            intRetValValue = GetXMLTextValue(strTagValue, intFileNumber)
            If intRetValValue = 1 Then
                asPost(iUBound) = strTagValue
            End If
        'Открывающий тэг email сотрудника.
        Case constrEMailTag
            intRetValValue = GetXMLTextValue(strTagValue, intFileNumber)
            If intRetValValue = 1 Then
                asEMail(iUBound) = strTagValue
            End If
        'Открывающий тэг названия компании.
        Case constrCompanyNameTag
            intRetValValue = GetXMLTextValue(strTagValue, intFileNumber)
            If intRetValValue = 1 Then
                strOrgName = strTagValue
            End If
        End Select
    End If
Loop

Close #intFileNumber

'Проверить причину завершения зачитывания файла - возникновение ошибки или достижение конца файла.
If -1 = intRetTagValue Or -1 = intRetValValue Then
    MsgBox("Sintaksicheskaja oshibka v zachitivaemom XML-faile")
    BuildOrgTreeFromXML = False
    Exit Function
End If

BuildOrgTreeFromXML = True
Exit Function

ErrHandle:
    MsgBox ("In performing the macros, an error has occured.", cdbExclamation)
    BuildOrgTreeFromXML = False
    Exit Function
End Function

'========================================================================================================================
'========================================================================================================================

'Увеличиваем размерности массивов для помещения в них данных нового ресурса
Sub RedimArrays(ByVal intUBound As Integer, ByVal intUBound2 As Integer)

    Dim aiTempAtt() As Integer
    Dim i As Integer
    Dim j As Integer
    Dim iOldUBound As Integer
    Dim iOldUBound2 As Integer

'Поскольку при Redim Preserve возможно изменение только последней размерности массива,
'сохраняем данные двумерного массива во временном хранилище.
    iOldUBound = iUBound
    iOldUBound2 = iUBound2
    ReDim aiTempAtt(iOldUBound, iOldUBound2) As Integer
    For i=0 To iOldUBound
        For j=0 To iOldUBound2
            aiTempAtt(i,j)=asSubordinates(i,j)
        Next
    Next

    iUBound = intUBound
    iUBound2 = intUBound2
     ReDim Preserve asID(intUBound) As String
     ReDim Preserve asChiefID(intUBound) As String
     ReDim Preserve asName(intUBound) As String
     ReDim Preserve asPost(intUBound) As String
     ReDim Preserve asEMail(intUBound) As String
     ReDim Preserve aiLevel(intUBound) As Integer
     ReDim Preserve adBranchWidth(intUBound) As Double
     ReDim Preserve adBranchHeight(intUBound) As Double
     ReDim Preserve abNewPage(intUBound) As Boolean
     ReDim Preserve asSubordCount(intUBound) As Integer
     ReDim asSubordinates(intUBound,intUBound2) As Integer

     asID(intUBound)=""
     asChiefID(intUBound)=""
     asName(intUBound)=""
     asPost(intUBound)=""
     asEMail(intUBound)=""
     aiLevel(intUBound)=0
     adBranchWidth(intUBound)=0
     adBranchHeight(intUBound)=0
     abNewPage(intUBound)=False
     asSubordCount(intUBound)=0

    For i=0 To iOldUBound
        For j=0 To iOldUBound2
            asSubordinates(i,j)=aiTempAtt(i,j)
        Next
    Next

End Sub

'========================================================================================================================
'========================================================================================================================

'Замена entity в строке, полученной из XML-файла на обозначаемый ею символ
Function ReReplaceSymbols(ByRef strText As String) As String
    Dim iFindPos As Integer
    Dim strRepSymbols As String

    strRepSymbols = ">"
    iFindPos = InStr(strText, strRepSymbols)
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & ">" & Right(strText, Len(strText) - iFindPos - Len(strRepSymbols) + 1 )
        iFindPos = InStr(iFindPos + 1, strText, strRepSymbols )
    Loop

    strRepSymbols = "<"
    iFindPos = InStr(strText, strRepSymbols)
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & "<" & Right(strText, Len(strText) - iFindPos - Len(strRepSymbols) + 1 )
        iFindPos = InStr(iFindPos + 1, strText, strRepSymbols )
    Loop

    strRepSymbols = "'"
    iFindPos = InStr(strText, strRepSymbols)
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & "'" & Right(strText, Len(strText) - iFindPos - Len(strRepSymbols) + 1 )
        iFindPos = InStr(iFindPos + 1, strText, strRepSymbols )
    Loop

    strRepSymbols = """
    iFindPos = InStr(strText, strRepSymbols)
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & """" & Right(strText, Len(strText) - iFindPos - Len(strRepSymbols) + 1 )
        iFindPos = InStr(iFindPos + 1, strText, strRepSymbols )
    Loop

    strRepSymbols = "&"
    iFindPos = InStr(strText, strRepSymbols)
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & "&" & Right(strText, Len(strText) - iFindPos - Len(strRepSymbols) + 1 )
        iFindPos = InStr(iFindPos + 1, strText, strRepSymbols )
    Loop

    ReReplaceSymbols = strText

End Function

'========================================================================================================================
'========================================================================================================================

'Заменить в строке символы перевода строки и возврата каретки на пробелы
Sub ReplaceChr10And13(ByRef strText As String)
    Dim iFindPos As Integer

    iFindPos = InStr(strText, Chr(10))
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & " " & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, Chr(10))
    Loop

    iFindPos = InStr(strText, Chr(13))
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & " " & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, Chr(13))
    Loop
End Sub

'========================================================================================================================
'========================================================================================================================

'Получаем значение XML-тэга. При этом считаем. что внутри данного тэга не могут находиться
'другие тэги, в том числе комментария.
Function GetXMLTextValue(ByRef strTagValue As String, ByVal intFileNumber As Integer) As Integer
    Dim intOldLen As Integer
    Dim bReadNextPart As Boolean
    Dim iNextTagPos As Integer

    intOldLen = 0

    strTagValue = strBuffer
    bReadNextPart=True

    Do
        'Найти начало закрывающего тэга
        iNextTagPos=InStr(strTagValue , "<")

        If iNextTagPos>0 Then
            'Если тэг найден, можно выйти из цикла и вернуть значение
            bReadNextPart=False
        Else
            'Если закрывающий тэг не найден и достигнут конец файла, функция возвращает ошибку.
            If EOF(intFileNumber) Then
                GetXMLTextValue = -1
                Exit Function
            End If
        End If

        'Если тэг не найден и конец файла еще не достигнут, зачитать из файла в буфер следующую порцию символов.
        If bReadNextPart Then
            strBuffer = Input$(conintInputSymbCount, intFileNumber)
            intOldLen = Len(strTagValue )
            strTagValue = strTagValue + strBuffer
        End If
    Loop While bReadNextPart

    'Получить значение тэга
    strTagValue = Left(strTagValue, iNextTagPos-1)
    'Заменить символы возврата каретки и перевода строки на пробелы
    ReplaceChr10And13(strTagValue)
    Trim$(strTagValue)
    'Заменить entity на символы, которые они представляют
    strTagValue = ReReplaceSymbols(strTagValue)
    'Удалить из буфера уже обработанную часть
    strBuffer = Mid(strBuffer, iNextTagPos-intOldLen)
    GetXMLTextValue = 1
End Function

'========================================================================================================================
'========================================================================================================================

'Загрузить в строковую переменную strTag следующий тэг.
Function GetXMLTag(ByRef strTag As String, ByVal intFileNumber As Integer) As Integer
    Dim intOldLen As Integer
    Dim iLt As Integer    'Положение первой скобки '<'
    Dim iGt As Integer    'Положение первой скобки '>'
    Dim iLt2 As Integer    'Положение второй скобки '<'
    Dim bReadNextPart As Boolean

    intOldLen = 0

    strTag = strBuffer
    bReadNextPart=True
    Do
        iLt=Instr(strTag, "<")
        iGt=Instr(strTag, ">")
        'В строке есть и открывающая, и закрывающая угловые скобки
        If iLt > 0 And iGt > 0 Then
            'Начерно проверить корректность расстановки угловых скобок
            If iLt < iGt Then 'Сперва стоит открывающая, затем закрывающая скобки
                'Проверяем дальше
                If iLt=Instr(strTag, "<!--") Then 'Наткнулись на открывающую скобку комментария
                    iGt=Instr(strTag, "-->")+2 'Ищем закрывающую скобку комментария. iGT, возможно, получает новое значение
                    If iGt - 2 > 0 Then
                        bReadNextPart = False 'О! Это уже весь комментарий!
                    End If
                Else  'Это-таки не комментарий
                    iLt2=Instr(iLt+1, strTag, "<")
                    If iLt2>0 And iLt2<iGt Then
                        GetXMLTag=-1 'Кто-то нахимичил со скобками "...<...<...>..."
                        Exit Function
                    Else
                        bReadNextPart = False
                    End If
                End If
            Else
                GetXMLTag=-1 'Караул! Скобки расставлены так, что сам черт ногу сломит! "...>...<..."
                Exit Function
            End If
        End If

        If bReadNextPart Then
            If EOF(intFileNumber) Then
                If iLt = 0 And iGt = 0 Then
                    GetXMLTag = 0 'Файл зачитан полностью: тэгов больше нет.
                Else
                    GetXMLTag = -1 'Файл зачитан полностью, но не хватает скобок. Возникла ошибка.
                End If
                Exit Function
            Else 'if the end not found, reading a new data portion to the buffer
                strBuffer = Input$(conintInputSymbCount, intFileNumber)
                intOldLen = Len(strTag)
                strTag = strTag + strBuffer
            End If
        End If
    Loop While bReadNextPart

    'Получить тэг
    strTag = Mid(strTag, iLt+1, iGt-iLt-1)
    'Удалить из буфера уже обработанную часть
    strBuffer = Mid(strBuffer, iGt-intOldLen+1)
    GetXMLTag = 1
End Function